home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / format.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  73.8 KB  |  2,372 lines
  1. ;;; -*- Package: FORMAT -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: format.lisp,v 1.25 92/11/06 04:15:56 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp.
  15. ;;;
  16. ;;; Written by William Lott, with lots of stuff stolen from the previous
  17. ;;; version by David Adam and later rewritten by Bill Maddox.
  18. ;;; 
  19.  
  20. (in-package "FORMAT")
  21. (use-package "EXT")
  22. (use-package "KERNEL")
  23.  
  24. (in-package "LISP")
  25. (export '(format formatter))
  26.  
  27. (in-package "FORMAT")
  28.  
  29. (defstruct (format-directive
  30.         (:print-function %print-format-directive))
  31.   (string (required-argument) :type simple-string)
  32.   (start (required-argument) :type (and unsigned-byte fixnum))
  33.   (end (required-argument) :type (and unsigned-byte fixnum))
  34.   (character (required-argument) :type base-character)
  35.   (colonp nil :type (member t nil))
  36.   (atsignp nil :type (member t nil))
  37.   (params nil :type list))
  38.  
  39. (defun %print-format-directive (struct stream depth)
  40.   (declare (ignore depth))
  41.   (print-unreadable-object (struct stream)
  42.     (write-string (format-directive-string struct) stream
  43.           :start (format-directive-start struct)
  44.           :end (format-directive-end struct))))
  45.  
  46. (defvar *format-directive-expanders*
  47.   (make-array char-code-limit :initial-element nil))
  48. (defvar *format-directive-interpreters*
  49.   (make-array char-code-limit :initial-element nil))
  50.  
  51. (defun %print-format-error (condition stream)
  52.   (cl:format stream
  53.          "~:[~;Error in format: ~]~
  54.           ~?~@[~%  ~A~%  ~V@T^~]"
  55.          (format-error-print-banner condition)
  56.          (format-error-complaint condition)
  57.          (format-error-arguments condition)
  58.          (format-error-control-string condition)
  59.          (format-error-offset condition)))
  60.  
  61. (defvar *default-format-error-control-string* nil)
  62. (defvar *default-format-error-offset* nil)
  63.  
  64. (define-condition format-error (error)
  65.   ((complaint)
  66.    (arguments :init-form nil)
  67.    (control-string :init-form *default-format-error-control-string*)
  68.    (offset :init-form *default-format-error-offset*)
  69.    (print-banner :init-form t))
  70.   (:report %print-format-error))
  71.  
  72.  
  73.  
  74. ;;;; TOKENIZE-CONTROL-STRING
  75.  
  76. (defun tokenize-control-string (string)
  77.   (declare (simple-string string))
  78.   (let ((index 0)
  79.     (end (length string))
  80.     (result nil))
  81.     (loop
  82.       (let ((next-directive (or (position #\~ string :start index) end)))
  83.     (when (> next-directive index)
  84.       (push (subseq string index next-directive) result))
  85.     (when (= next-directive end)
  86.       (return))
  87.     (let ((directive (parse-directive string next-directive)))
  88.       (push directive result)
  89.       (setf index (format-directive-end directive)))))
  90.     (nreverse result)))
  91.  
  92. (defun parse-directive (string start)
  93.   (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
  94.     (end (length string)))
  95.     (flet ((get-char ()
  96.          (if (= posn end)
  97.          (error 'format-error
  98.             :complaint "String ended before directive was found."
  99.             :control-string string
  100.             :offset start)
  101.          (schar string posn))))
  102.       (loop
  103.     (let ((char (get-char)))
  104.       (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
  105.          (multiple-value-bind
  106.              (param new-posn)
  107.              (parse-integer string :start posn :junk-allowed t)
  108.            (push (cons posn param) params)
  109.            (setf posn new-posn)
  110.            (case (get-char)
  111.              (#\,)
  112.              ((#\: #\@)
  113.               (decf posn))
  114.              (t
  115.               (return)))))
  116.         ((or (char= char #\v) (char= char #\V))
  117.          (push (cons posn :arg) params)
  118.          (incf posn)
  119.          (case (get-char)
  120.            (#\,)
  121.            ((#\: #\@)
  122.             (decf posn))
  123.            (t
  124.             (return))))
  125.         ((char= char #\#)
  126.          (push (cons posn :remaining) params)
  127.          (incf posn)
  128.          (case (get-char)
  129.            (#\,)
  130.            ((#\: #\@)
  131.             (decf posn))
  132.            (t
  133.             (return))))
  134.         ((char= char #\')
  135.          (incf posn)
  136.          (push (cons posn (get-char)) params))
  137.         ((char= char #\,)
  138.          (push (cons (1- posn) nil) params))
  139.         ((char= char #\:)
  140.          (if colonp
  141.              (error 'format-error
  142.                 :complaint "Too many colons supplied."
  143.                 :control-string string
  144.                 :offset posn)
  145.              (setf colonp t)))
  146.         ((char= char #\@)
  147.          (if atsignp
  148.              (error 'format-error
  149.                 :complaint "Too many at-signs supplied."
  150.                 :control-string string
  151.                 :offset posn)
  152.              (setf atsignp t)))
  153.         (t
  154.          (when (char= (schar string (1- posn)) #\,)
  155.            (push (cons (1- posn) nil) params))
  156.          (return))))
  157.     (incf posn))
  158.       (let ((char (get-char)))
  159.     (when (char= char #\/)
  160.       (let ((closing-slash (position #\/ string :start (1+ posn))))
  161.         (if closing-slash
  162.         (setf posn closing-slash)
  163.         (error 'format-error
  164.                :complaint "No matching closing slash."
  165.                :control-string string
  166.                :offset posn))))
  167.     (make-format-directive
  168.         :string string :start start :end (1+ posn)
  169.         :character (char-upcase char)
  170.         :colonp colonp :atsignp atsignp
  171.         :params (nreverse params))))))
  172.  
  173.  
  174. ;;;; Specials used to communicate information.
  175.  
  176. ;;; *UP-UP-AND-OUT-ALLOWED* -- internal.
  177. ;;;
  178. ;;; Used both by the expansion stuff and the interpreter stuff.  When it is
  179. ;;; non-NIL, up-up-and-out (~:^) is allowed.  Otherwise, ~:^ isn't allowed.
  180. ;;;
  181. (defvar *up-up-and-out-allowed* nil)
  182.  
  183. ;;; *LOGICAL-BLOCK-POPPER* -- internal.
  184. ;;;
  185. ;;; Used by the interpreter stuff.  When it non-NIL, its a function that will
  186. ;;; invoke PPRINT-POP in the right lexical environemnt.
  187. ;;;
  188. (defvar *logical-block-popper* nil)
  189.  
  190. ;;; *EXPANDER-NEXT-ARG-MACRO* -- internal.
  191. ;;;
  192. ;;; Used by the expander stuff.  This is bindable so that ~<...~:>
  193. ;;; can change it.
  194. ;;;
  195. (defvar *expander-next-arg-macro* 'expander-next-arg)
  196.  
  197. ;;; *ONLY-SIMPLE-ARGS* -- internal.
  198. ;;;
  199. ;;; Used by the expander stuff.  Initially starts as T, and gets set to NIL
  200. ;;; if someone needs to do something strange with the arg list (like use
  201. ;;; the rest, or something).
  202. ;;; 
  203. (defvar *only-simple-args*)
  204.  
  205. ;;; *ORIG-ARGS-AVAILABLE* -- internal.
  206. ;;;
  207. ;;; Used by the expander stuff.  We do an initial pass with this as NIL.
  208. ;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try
  209. ;;; again with it bound to T.  If this is T, we don't try to do anything
  210. ;;; fancy with args.
  211. ;;; 
  212. (defvar *orig-args-available* nil)
  213.  
  214. ;;; *SIMPLE-ARGS* -- internal.
  215. ;;;
  216. ;;; Used by the expander stuff.  List of (symbol . offset) for simple args.
  217. ;;; 
  218. (defvar *simple-args*)
  219.  
  220.  
  221.  
  222.  
  223. ;;;; FORMAT
  224.  
  225. (defun format (destination control-string &rest format-arguments)
  226.   "Provides various facilities for formatting output.
  227.   CONTROL-STRING contains a string to be output, possibly with embedded
  228.   directives, which are flagged with the escape character \"~\".  Directives
  229.   generally expand into additional text to be output, usually consuming one
  230.   or more of the FORMAT-ARGUMENTS in the process.  A few useful directives
  231.   are:
  232.         ~A or ~nA     Prints one argument as if by PRINC
  233.         ~S or ~nS     Prints one argument as if by PRIN1
  234.         ~D or ~nD     Prints one argument as a decimal integer
  235.         ~%            Does a TERPRI
  236.         ~&            Does a FRESH-LINE
  237.  
  238.          where n is the width of the field in which the object is printed.
  239.   
  240.   DESTINATION controls where the result will go.  If DESTINATION is T, then
  241.   the output is sent to the standard output stream.  If it is NIL, then the
  242.   output is returned in a string as the value of the call.  Otherwise,
  243.   DESTINATION must be a stream to which the output will be sent.
  244.  
  245.   Example:   (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
  246.  
  247.   FORMAT has many additional capabilities not described here.  Consult the
  248.   manual for details."
  249.   (etypecase destination
  250.     (null
  251.      (with-output-to-string (stream)
  252.        (%format stream control-string format-arguments)))
  253.     (string
  254.      (with-output-to-string (stream destination)
  255.        (%format stream control-string format-arguments)))
  256.     ((member t)
  257.      (%format *standard-output* control-string format-arguments)
  258.      nil)
  259.     (stream
  260.      (%format destination control-string format-arguments)
  261.      nil)))
  262.  
  263. (defun %format (stream string-or-fun orig-args &optional (args orig-args))
  264.   (if (functionp string-or-fun)
  265.       (apply string-or-fun stream args)
  266.       (catch 'up-and-out
  267.     (let* ((string (etypecase string-or-fun
  268.              (simple-string
  269.               string-or-fun)
  270.              (string
  271.               (coerce string-or-fun 'simple-string))))
  272.            (*default-format-error-control-string* string)
  273.            (*logical-block-popper* nil))
  274.       (interpret-directive-list stream (tokenize-control-string string)
  275.                     orig-args args)))))
  276.  
  277. (defun interpret-directive-list (stream directives orig-args args)
  278.   (if directives
  279.       (let ((directive (car directives)))
  280.     (etypecase directive
  281.       (simple-string
  282.        (write-string directive stream)
  283.        (interpret-directive-list stream (cdr directives) orig-args args))
  284.       (format-directive
  285.        (multiple-value-bind
  286.            (new-directives new-args)
  287.            (let ((function
  288.               (svref *format-directive-interpreters*
  289.                  (char-code (format-directive-character
  290.                      directive))))
  291.              (*default-format-error-offset*
  292.               (1- (format-directive-end directive))))
  293.          (unless function
  294.            (error 'format-error
  295.               :complaint "Unknown format directive."))
  296.          (multiple-value-bind
  297.              (new-directives new-args)
  298.              (funcall function stream directive
  299.                   (cdr directives) orig-args args)
  300.            (values new-directives new-args)))
  301.          (interpret-directive-list stream new-directives
  302.                        orig-args new-args)))))
  303.       args))
  304.  
  305.  
  306. ;;;; FORMATTER
  307.  
  308. (defmacro formatter (control-string)
  309.   `#',(%formatter control-string))
  310.  
  311. (defun %formatter (control-string)
  312.   (block nil
  313.     (catch 'need-orig-args
  314.       (let* ((*simple-args* nil)
  315.          (*only-simple-args* t)
  316.          (guts (expand-control-string control-string))
  317.          (args nil))
  318.     (dolist (arg *simple-args*)
  319.       (push `(,(car arg)
  320.           (error
  321.            'format-error
  322.            :complaint "Required argument missing"
  323.            :control-string ,control-string
  324.            :offset ,(cdr arg)))
  325.         args))
  326.     (return `(lambda (stream &optional ,@args &rest args)
  327.            ,guts
  328.            args))))
  329.     (let ((*orig-args-available* t)
  330.       (*only-simple-args* nil))
  331.       `(lambda (stream &rest orig-args)
  332.      (let ((args orig-args))
  333.        ,(expand-control-string control-string)
  334.        args)))))
  335.  
  336. (defun expand-control-string (string)
  337.   (let* ((string (etypecase string
  338.            (simple-string
  339.             string)
  340.            (string
  341.             (coerce string 'simple-string))))
  342.      (*default-format-error-control-string* string)
  343.      (directives (tokenize-control-string string)))
  344.     `(block nil
  345.        ,@(expand-directive-list directives))))
  346.  
  347. (defun expand-directive-list (directives)
  348.   (let ((results nil)
  349.     (remaining-directives directives))
  350.     (loop
  351.       (unless remaining-directives
  352.     (return))
  353.       (multiple-value-bind
  354.       (form new-directives)
  355.       (expand-directive (car remaining-directives)
  356.                 (cdr remaining-directives))
  357.     (push form results)
  358.     (setf remaining-directives new-directives)))
  359.     (reverse results)))
  360.  
  361. (defun expand-directive (directive more-directives)
  362.   (etypecase directive
  363.     (format-directive
  364.      (let ((expander
  365.         (aref *format-directive-expanders*
  366.           (char-code (format-directive-character directive))))
  367.        (*default-format-error-offset*
  368.         (1- (format-directive-end directive))))
  369.        (if expander
  370.        (funcall expander directive more-directives)
  371.        (error 'format-error
  372.           :complaint "Unknown directive."))))
  373.     (simple-string
  374.      (values `(write-string ,directive stream)
  375.          more-directives))))
  376.  
  377. (defun expand-next-arg (&optional offset)
  378.   (if (or *orig-args-available* (not *only-simple-args*))
  379.       `(,*expander-next-arg-macro*
  380.     ,*default-format-error-control-string*
  381.     ,(or offset *default-format-error-offset*))
  382.       (let ((symbol (gensym "FORMAT-ARG-")))
  383.     (push (cons symbol (or offset *default-format-error-offset*))
  384.           *simple-args*)
  385.     symbol)))
  386.  
  387. (defun need-hairy-args ()
  388.   (when *only-simple-args*
  389.     ))
  390.  
  391.  
  392. ;;;; Format directive definition macros and runtime support.
  393.  
  394. (defmacro expander-next-arg (string offset)
  395.   `(if args
  396.        (pop args)
  397.        (error 'format-error
  398.           :complaint "No more arguments."
  399.           :control-string ,string
  400.           :offset ,offset)))
  401.  
  402. (defmacro expander-pprint-next-arg (string offset)
  403.   `(progn
  404.      (when (null args)
  405.        (error 'format-error
  406.           :complaint "No more arguments."
  407.           :control-string ,string
  408.           :offset ,offset))
  409.      (pprint-pop)
  410.      (pop args)))
  411.  
  412. (eval-when (compile eval)
  413.  
  414. ;;; NEXT-ARG -- internal.
  415. ;;;
  416. ;;; This macro is used to extract the next argument from the current arg list.
  417. ;;; This is the version used by format directive interpreters.
  418. ;;; 
  419. (defmacro next-arg (&optional offset)
  420.   `(progn
  421.      (when (null args)
  422.        (error 'format-error
  423.           :complaint "No more arguments."
  424.           ,@(when offset
  425.           `(:offset ,offset))))
  426.      (when *logical-block-popper*
  427.        (funcall *logical-block-popper*))
  428.      (pop args)))
  429.  
  430. (defmacro def-complex-format-directive (char lambda-list &body body)
  431.   (let ((defun-name (intern (cl:format nil
  432.                        "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
  433.                        char)))
  434.     (directive (gensym))
  435.     (directives (if lambda-list (car (last lambda-list)) (gensym))))
  436.     `(progn
  437.        (defun ,defun-name (,directive ,directives)
  438.      ,@(if lambda-list
  439.            `((let ,(mapcar #'(lambda (var)
  440.                    `(,var
  441.                      (,(intern (concatenate
  442.                         'string
  443.                         "FORMAT-DIRECTIVE-"
  444.                         (symbol-name var))
  445.                            (symbol-package 'foo))
  446.                       ,directive)))
  447.                    (butlast lambda-list))
  448.            ,@body))
  449.            `((declare (ignore ,directive ,directives))
  450.          ,@body)))
  451.        (%set-format-directive-expander ,char #',defun-name))))
  452.  
  453. (defmacro def-format-directive (char lambda-list &body body)
  454.   (let ((directives (gensym))
  455.     (declarations nil)
  456.     (body-without-decls body))
  457.     (loop
  458.       (let ((form (car body-without-decls)))
  459.     (unless (and (consp form) (eq (car form) 'declare))
  460.       (return))
  461.     (push (pop body-without-decls) declarations)))
  462.     (setf declarations (reverse declarations))
  463.     `(def-complex-format-directive ,char (,@lambda-list ,directives)
  464.        ,@declarations
  465.        (values (progn ,@body-without-decls)
  466.            ,directives))))
  467.  
  468. (defmacro expand-bind-defaults (specs params &body body)
  469.   (once-only ((params params))
  470.     (if specs
  471.     (collect ((expander-bindings) (runtime-bindings))
  472.          (dolist (spec specs)
  473.            (destructuring-bind (var default) spec
  474.              (let ((symbol (gensym)))
  475.                (expander-bindings
  476.             `(,var ',symbol))
  477.                (runtime-bindings
  478.             `(list ',symbol
  479.                    (let* ((param-and-offset (pop ,params))
  480.                       (offset (car param-and-offset))
  481.                       (param (cdr param-and-offset)))
  482.                  (case param
  483.                    (:arg `(or ,(expand-next-arg offset)
  484.                           ,,default))
  485.                    (:remaining
  486.                     (setf *only-simple-args* nil)
  487.                     '(length args))
  488.                    ((nil) ,default)
  489.                    (t param))))))))
  490.          `(let ,(expander-bindings)
  491.             `(let ,(list ,@(runtime-bindings))
  492.                ,@(if ,params
  493.                  (error 'format-error
  494.                     :complaint
  495.                 "Too many parameters, expected no more than ~D"
  496.                     :arguments (list ,(length specs))
  497.                     :offset (caar ,params)))
  498.                ,,@body)))
  499.     `(progn
  500.        (when ,params
  501.          (error 'format-error
  502.             :complaint "Too many parameters, expected no more than 0"
  503.             :offset (caar ,params)))
  504.        ,@body))))
  505.  
  506. (defmacro def-complex-format-interpreter (char lambda-list &body body)
  507.   (let ((defun-name
  508.         (intern (cl:format nil "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
  509.                    char)))
  510.     (directive (gensym))
  511.     (directives (if lambda-list (car (last lambda-list)) (gensym))))
  512.     `(progn
  513.        (defun ,defun-name (stream ,directive ,directives orig-args args)
  514.      (declare (ignorable stream orig-args args))
  515.      ,@(if lambda-list
  516.            `((let ,(mapcar #'(lambda (var)
  517.                    `(,var
  518.                      (,(intern (concatenate
  519.                         'string
  520.                         "FORMAT-DIRECTIVE-"
  521.                         (symbol-name var))
  522.                            (symbol-package 'foo))
  523.                       ,directive)))
  524.                    (butlast lambda-list))
  525.            (values (progn ,@body) args)))
  526.            `((declare (ignore ,directive ,directives))
  527.          ,@body)))
  528.        (%set-format-directive-interpreter ,char #',defun-name))))
  529.  
  530. (defmacro def-format-interpreter (char lambda-list &body body)
  531.   (let ((directives (gensym)))
  532.     `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
  533.        ,@body
  534.        ,directives)))
  535.  
  536. (defmacro interpret-bind-defaults (specs params &body body)
  537.   (once-only ((params params))
  538.     (collect ((bindings))
  539.       (dolist (spec specs)
  540.     (destructuring-bind (var default) spec
  541.       (bindings `(,var (let* ((param-and-offset (pop ,params))
  542.                   (offset (car param-and-offset))
  543.                   (param (cdr param-and-offset)))
  544.                  (case param
  545.                    (:arg (next-arg offset))
  546.                    (:remaining (length args))
  547.                    ((nil) ,default)
  548.                    (t param)))))))
  549.       `(let* ,(bindings)
  550.      (when ,params
  551.        (error 'format-error
  552.           :complaint
  553.           "Too many parameters, expected no more than ~D"
  554.           :arguments (list ,(length specs))
  555.           :offset (caar ,params)))
  556.      ,@body))))
  557.  
  558. ); eval-when
  559.  
  560. (defun %set-format-directive-expander (char fn)
  561.   (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
  562.   char)
  563.  
  564. (defun %set-format-directive-interpreter (char fn)
  565.   (setf (aref *format-directive-interpreters*
  566.           (char-code (char-upcase char)))
  567.     fn)
  568.   char)
  569.  
  570. (defun find-directive (directives kind stop-at-semi)
  571.   (if directives
  572.       (let ((next (car directives)))
  573.     (if (format-directive-p next)
  574.         (let ((char (format-directive-character next)))
  575.           (if (or (char= kind char)
  576.               (and stop-at-semi (char= char #\;)))
  577.           (car directives)
  578.           (find-directive
  579.            (cdr (flet ((after (char)
  580.                  (member (find-directive (cdr directives)
  581.                              char
  582.                              nil)
  583.                      directives)))
  584.               (case char
  585.                 (#\( (after #\)))
  586.                 (#\< (after #\>))
  587.                 (#\[ (after #\]))
  588.                 (#\{ (after #\}))
  589.                 (t directives))))
  590.            kind stop-at-semi)))
  591.         (find-directive (cdr directives) kind stop-at-semi)))))
  592.  
  593.  
  594. ;;;; Simple outputting noise.
  595.  
  596. (defun format-write-field (stream string mincol colinc minpad padchar padleft)
  597.   (unless padleft
  598.     (write-string string stream))
  599.   (dotimes (i minpad)
  600.     (write-char padchar stream))
  601.   (do ((chars (+ (length string) minpad) (+ chars colinc)))
  602.       ((>= chars mincol))
  603.     (dotimes (i colinc)
  604.       (write-char padchar stream)))
  605.   (when padleft
  606.     (write-string string stream)))
  607.  
  608. (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
  609.   (format-write-field stream
  610.               (if (or arg (not colonp))
  611.               (princ-to-string arg)
  612.               "()")
  613.               mincol colinc minpad padchar atsignp))
  614.  
  615. (def-format-directive #\A (colonp atsignp params)
  616.   (if params
  617.       (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
  618.                  (padchar #\space))
  619.              params
  620.     `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
  621.                ,mincol ,colinc ,minpad ,padchar))
  622.       `(princ ,(if colonp
  623.            `(or ,(expand-next-arg) "()")
  624.            (expand-next-arg))
  625.           stream)))
  626.  
  627. (def-format-interpreter #\A (colonp atsignp params)
  628.   (if params
  629.       (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
  630.                 (padchar #\space))
  631.              params
  632.     (format-princ stream (next-arg) colonp atsignp
  633.               mincol colinc minpad padchar))
  634.       (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
  635.  
  636. (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
  637.   (format-write-field stream
  638.               (if (or arg (not colonp))
  639.               (prin1-to-string arg)
  640.               "()")
  641.               mincol colinc minpad padchar atsignp))
  642.  
  643. (def-format-directive #\S (colonp atsignp params)
  644.   (cond (params
  645.      (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
  646.                 (padchar #\space))
  647.             params
  648.        `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
  649.               ,mincol ,colinc ,minpad ,padchar)))
  650.     (colonp
  651.      `(let ((arg ,(expand-next-arg)))
  652.         (if arg
  653.         (prin1 arg stream)
  654.         (princ "()" stream))))
  655.     (t
  656.      `(prin1 ,(expand-next-arg) stream))))
  657.  
  658. (def-format-interpreter #\S (colonp atsignp params)
  659.   (cond (params
  660.      (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
  661.                    (padchar #\space))
  662.             params
  663.        (format-prin1 stream (next-arg) colonp atsignp
  664.              mincol colinc minpad padchar)))
  665.     (colonp
  666.      (let ((arg (next-arg)))
  667.        (if arg
  668.            (prin1 arg stream)
  669.            (princ "()" stream))))
  670.     (t
  671.      (prin1 (next-arg) stream))))
  672.  
  673. (def-format-directive #\C (colonp atsignp params)
  674.   (expand-bind-defaults () params
  675.     (if colonp
  676.     `(format-print-named-character ,(expand-next-arg) stream)
  677.     (if atsignp
  678.         `(prin1 ,(expand-next-arg) stream)
  679.         `(write-char ,(expand-next-arg) stream)))))
  680.  
  681. (def-format-interpreter #\C (colonp atsignp params)
  682.   (interpret-bind-defaults () params
  683.     (if colonp
  684.     (format-print-named-character (next-arg) stream)
  685.     (if atsignp
  686.         (prin1 (next-arg) stream)
  687.         (write-char (next-arg) stream)))))
  688.  
  689. (defun format-print-named-character (char stream)
  690.   (let* ((name (char-name char)))
  691.     (cond (name
  692.        (write-string (string-capitalize name) stream))
  693.       ((<= 0 (char-code char) 31)
  694.        ;; Print control characters as "^"<char>
  695.        (write-char #\^ stream)
  696.        (write-char (code-char (+ 64 (char-code char))) stream))
  697.       (t
  698.        (write-char char stream)))))
  699.  
  700. (def-format-directive #\W (colonp atsignp params)
  701.   (expand-bind-defaults () params
  702.     (if (or colonp atsignp)
  703.     `(let (,@(when colonp
  704.            '((*print-pretty* t)))
  705.            ,@(when atsignp
  706.            '((*print-level* nil)
  707.              (*print-length* nil))))
  708.        (output-object ,(expand-next-arg) stream))
  709.     `(output-object ,(expand-next-arg) stream))))
  710.  
  711. (def-format-interpreter #\W (colonp atsignp params)
  712.   (interpret-bind-defaults () params
  713.     (let ((*print-pretty* (or colonp *print-pretty*))
  714.       (*print-level* (and atsignp *print-level*))
  715.       (*print-length* (and atsignp *print-length*)))
  716.       (output-object (next-arg) stream))))
  717.  
  718.  
  719. ;;;; Integer outputting.
  720.  
  721. ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
  722. ;;; directives.  The parameters are interpreted as defined for ~D.
  723. ;;;
  724. (defun format-print-integer (stream number print-commas-p print-sign-p
  725.                  radix mincol padchar commachar commainterval)
  726.   (let ((*print-base* radix)
  727.     (*print-radix* nil))
  728.     (if (integerp number)
  729.     (let* ((text (princ-to-string (abs number)))
  730.            (commaed (if print-commas-p
  731.                 (format-add-commas text commachar commainterval)
  732.                 text))
  733.            (signed (cond ((minusp number)
  734.                   (concatenate 'string "-" commaed))
  735.                  (print-sign-p
  736.                   (concatenate 'string "+" commaed))
  737.                  (t commaed))))
  738.       ;; colinc = 1, minpad = 0, padleft = t
  739.       (format-write-field stream signed mincol 1 0 padchar t))
  740.     (princ number))))
  741.  
  742. (defun format-add-commas (string commachar commainterval)
  743.   (let ((length (length string)))
  744.     (multiple-value-bind (commas extra)
  745.              (truncate (1- length) commainterval)
  746.       (let ((new-string (make-string (+ length commas)))
  747.         (first-comma (1+ extra)))
  748.     (replace new-string string :end1 first-comma :end2 first-comma)
  749.     (do ((src first-comma (+ src commainterval))
  750.          (dst first-comma (+ dst commainterval 1)))
  751.         ((= src length))
  752.       (setf (schar new-string dst) commachar)
  753.       (replace new-string string :start1 (1+ dst)
  754.            :start2 src :end2 (+ src commainterval)))
  755.     new-string))))
  756.  
  757. (defun expand-format-integer (base colonp atsignp params)
  758.   (if (or colonp atsignp params)
  759.       (expand-bind-defaults
  760.       ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
  761.       params
  762.     `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
  763.                    ,base ,mincol ,padchar ,commachar
  764.                    ,commainterval))
  765.       `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
  766.           :escape nil)))
  767.  
  768. (defmacro interpret-format-integer (base)
  769.   `(if (or colonp atsignp params)
  770.        (interpret-bind-defaults
  771.        ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
  772.        params
  773.      (format-print-integer stream (next-arg) colonp atsignp ,base mincol
  774.                    padchar commachar commainterval))
  775.        (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
  776.  
  777. (def-format-directive #\D (colonp atsignp params)
  778.   (expand-format-integer 10 colonp atsignp params))
  779.  
  780. (def-format-interpreter #\D (colonp atsignp params)
  781.   (interpret-format-integer 10))
  782.  
  783. (def-format-directive #\B (colonp atsignp params)
  784.   (expand-format-integer 2 colonp atsignp params))
  785.  
  786. (def-format-interpreter #\B (colonp atsignp params)
  787.   (interpret-format-integer 2))
  788.  
  789. (def-format-directive #\O (colonp atsignp params)
  790.   (expand-format-integer 8 colonp atsignp params))
  791.  
  792. (def-format-interpreter #\O (colonp atsignp params)
  793.   (interpret-format-integer 8))
  794.  
  795. (def-format-directive #\X (colonp atsignp params)
  796.   (expand-format-integer 16 colonp atsignp params))
  797.  
  798. (def-format-interpreter #\X (colonp atsignp params)
  799.   (interpret-format-integer 16))
  800.  
  801. (def-format-directive #\R (colonp atsignp params)
  802.   (if params
  803.       (expand-bind-defaults
  804.       ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
  805.        (commainterval 3))
  806.       params
  807.     `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
  808.                    ,base ,mincol
  809.                    ,padchar ,commachar ,commainterval))
  810.       (if atsignp
  811.       (if colonp
  812.           `(format-print-old-roman stream ,(expand-next-arg))
  813.           `(format-print-roman stream ,(expand-next-arg)))
  814.       (if colonp
  815.           `(format-print-ordinal stream ,(expand-next-arg))
  816.           `(format-print-cardinal stream ,(expand-next-arg))))))
  817.  
  818. (def-format-interpreter #\R (colonp atsignp params)
  819.   (if params
  820.       (interpret-bind-defaults
  821.       ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
  822.        (commainterval 3))
  823.       params
  824.     (format-print-integer stream (next-arg) colonp atsignp base mincol
  825.                   padchar commachar commainterval))
  826.       (if atsignp
  827.       (if colonp
  828.           (format-print-old-roman stream (next-arg))
  829.           (format-print-roman stream (next-arg)))
  830.       (if colonp
  831.           (format-print-ordinal stream (next-arg))
  832.           (format-print-cardinal stream (next-arg))))))
  833.  
  834.  
  835. (defconstant cardinal-ones
  836.   #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
  837.  
  838. (defconstant cardinal-tens
  839.   #(nil nil "twenty" "thirty" "forty"
  840.     "fifty" "sixty" "seventy" "eighty" "ninety"))
  841.  
  842. (defconstant cardinal-teens
  843.   #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
  844.     "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
  845.  
  846. (defconstant cardinal-periods
  847.   #("" " thousand" " million" " billion" " trillion" " quadrillion"
  848.     " quintillion" " sextillion" " septillion" " octillion" " nonillion"
  849.     " decillion"))
  850.  
  851. (defconstant ordinal-ones
  852.   #(nil "first" "second" "third" "fourth"
  853.     "fifth" "sixth" "seventh" "eighth" "ninth")
  854.   "Table of ordinal ones-place digits in English")
  855.  
  856. (defconstant ordinal-tens 
  857.   #(nil "tenth" "twentieth" "thirtieth" "fortieth"
  858.     "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
  859.   "Table of ordinal tens-place digits in English")
  860.  
  861. (defun format-print-small-cardinal (stream n)
  862.   (multiple-value-bind 
  863.       (hundreds rem) (truncate n 100)
  864.     (when (plusp hundreds)
  865.       (write-string (svref cardinal-ones hundreds) stream)
  866.       (write-string " hundred" stream)
  867.       (when (plusp rem)
  868.     (write-char #\space stream)))
  869.     (when (plusp rem)
  870.       (multiple-value-bind (tens ones)
  871.                (truncate rem 10)
  872.        (cond ((< 1 tens)
  873.           (write-string (svref cardinal-tens tens) stream)
  874.           (when (plusp ones)
  875.         (write-char #\- stream)
  876.         (write-string (svref cardinal-ones ones) stream)))
  877.          ((= tens 1)
  878.           (write-string (svref cardinal-teens ones) stream))
  879.          ((plusp ones)
  880.           (write-string (svref cardinal-ones ones) stream)))))))
  881.  
  882. (defun format-print-cardinal (stream n)
  883.   (cond ((minusp n)
  884.      (write-string "negative " stream)
  885.      (format-print-cardinal-aux stream (- n) 0 n))
  886.     ((zerop n)
  887.      (write-string "zero" stream))
  888.     (t
  889.      (format-print-cardinal-aux stream n 0 n))))
  890.  
  891. (defun format-print-cardinal-aux (stream n period err)
  892.   (multiple-value-bind (beyond here) (truncate n 1000)
  893.     (unless (<= period 10)
  894.       (error "Number too large to print in English: ~:D" err))
  895.     (unless (zerop beyond)
  896.       (format-print-cardinal-aux stream beyond (1+ period) err))
  897.     (unless (zerop here)
  898.       (unless (zerop beyond)
  899.     (write-char #\space stream))
  900.       (format-print-small-cardinal stream here)
  901.       (write-string (svref cardinal-periods period) stream))))
  902.  
  903. (defun format-print-ordinal (stream n)
  904.   (when (minusp n)
  905.     (write-string "negative " stream))
  906.   (let ((number (abs n)))
  907.     (multiple-value-bind
  908.     (top bot) (truncate number 100)
  909.       (unless (zerop top)
  910.     (format-print-cardinal stream (- number bot)))
  911.       (when (and (plusp top) (plusp bot))
  912.     (write-char #\space stream))
  913.       (multiple-value-bind
  914.       (tens ones) (truncate bot 10)
  915.     (cond ((= bot 12) (write-string "twelfth" stream))
  916.           ((= tens 1)
  917.            (write-string (svref cardinal-teens ones) stream);;;RAD
  918.            (write-string "th" stream))
  919.           ((and (zerop tens) (plusp ones))
  920.            (write-string (svref ordinal-ones ones) stream))
  921.           ((and (zerop ones)(plusp tens))
  922.            (write-string (svref ordinal-tens tens) stream))
  923.           ((plusp bot)
  924.            (write-string (svref cardinal-tens tens) stream)
  925.            (write-char #\- stream)
  926.            (write-string (svref ordinal-ones ones) stream))
  927.           ((plusp number)
  928.            (write-string "th" stream))
  929.           (t
  930.            (write-string "zeroeth" stream)))))))
  931.  
  932. ;;; Print Roman numerals
  933.  
  934. (defun format-print-old-roman (stream n)
  935.   (unless (< 0 n 5000)
  936.     (error "Number too large to print in old Roman numerals: ~:D" n))
  937.   (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
  938.        (val-list '(500 100 50 10 5 1) (cdr val-list))
  939.        (cur-char #\M (car char-list))
  940.        (cur-val 1000 (car val-list))
  941.        (start n (do ((i start (progn
  942.                 (write-char cur-char stream)
  943.                 (- i cur-val))))
  944.             ((< i cur-val) i))))
  945.       ((zerop start))))
  946.  
  947. (defun format-print-roman (stream n)
  948.   (unless (< 0 n 4000)
  949.     (error "Number too large to print in Roman numerals: ~:D" n))
  950.   (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
  951.        (val-list '(500 100 50 10 5 1) (cdr val-list))
  952.        (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
  953.        (sub-val '(100 10 10 1 1 0) (cdr sub-val))
  954.        (cur-char #\M (car char-list))
  955.        (cur-val 1000 (car val-list))
  956.        (cur-sub-char #\C (car sub-chars))
  957.        (cur-sub-val 100 (car sub-val))
  958.        (start n (do ((i start (progn
  959.                 (write-char cur-char stream)
  960.                 (- i cur-val))))
  961.             ((< i cur-val)
  962.              (cond ((<= (- cur-val cur-sub-val) i)
  963.                 (write-char cur-sub-char stream)
  964.                 (write-char cur-char stream)
  965.                 (- i (- cur-val cur-sub-val)))
  966.                (t i))))))
  967.       ((zerop start))))
  968.  
  969.  
  970. ;;;; Plural.
  971.  
  972. (def-format-directive #\P (colonp atsignp params end)
  973.   (expand-bind-defaults () params
  974.     (let ((arg (cond
  975.         ((not colonp)
  976.          (expand-next-arg))
  977.         (*orig-args-available*
  978.          `(if (eq orig-args args)
  979.               (error 'format-error
  980.                  :complaint "No previous argument."
  981.                  :offset ,(1- end))
  982.               (do ((arg-ptr orig-args (cdr arg-ptr)))
  983.               ((eq (cdr arg-ptr) args)
  984.                (car arg-ptr)))))
  985.         (*only-simple-args*
  986.          (unless *simple-args*
  987.            (error 'format-error
  988.               :complaint "No previous argument."))
  989.          (caar *simple-args*))
  990.         (t
  991.          (throw 'need-orig-args nil)))))
  992.       (if atsignp
  993.       `(write-string (if (eql ,arg 1) "y" "ies") stream)
  994.       `(unless (eql ,arg 1) (write-char #\s stream))))))
  995.  
  996. (def-format-interpreter #\P (colonp atsignp params)
  997.   (interpret-bind-defaults () params
  998.     (let ((arg (if colonp
  999.            (if (eq orig-args args)
  1000.                (error 'format-error
  1001.                   :complaint "No previous argument.")
  1002.                (do ((arg-ptr orig-args (cdr arg-ptr)))
  1003.                ((eq (cdr arg-ptr) args)
  1004.                 (car arg-ptr))))
  1005.            (next-arg))))
  1006.       (if atsignp
  1007.       (write-string (if (eql arg 1) "y" "ies") stream)
  1008.       (unless (eql arg 1) (write-char #\s stream))))))
  1009.  
  1010.  
  1011. ;;;; Floating point noise.
  1012.  
  1013. (defun decimal-string (n)
  1014.   (write-to-string n :base 10 :radix nil :escape nil))
  1015.  
  1016. (def-format-directive #\F (colonp atsignp params)
  1017.   (when colonp
  1018.     (error 'format-error
  1019.        :complaint
  1020.        "Cannot specify the colon modifier with this directive."))
  1021.   (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
  1022.     `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
  1023.  
  1024. (def-format-interpreter #\F (colonp atsignp params)
  1025.   (when colonp
  1026.     (error 'format-error
  1027.        :complaint
  1028.        "Cannot specify the colon modifier with this directive."))
  1029.   (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
  1030.                params
  1031.     (format-fixed stream (next-arg) w d k ovf pad atsignp)))
  1032.  
  1033. (defun format-fixed (stream number w d k ovf pad atsign)
  1034.   (if (floatp number)
  1035.       (format-fixed-aux stream number w d k ovf pad atsign)
  1036.       (if (rationalp number)
  1037.       (format-fixed-aux stream
  1038.                 (coerce number 'single-float)
  1039.                 w d k ovf pad atsign)
  1040.       (format-write-field stream
  1041.                   (decimal-string number)
  1042.                   w 1 0 #\space t))))
  1043.  
  1044. ;;; We return true if we overflowed, so that ~G can output the overflow char
  1045. ;;; instead of spaces.
  1046. ;;;
  1047. (defun format-fixed-aux (stream number w d k ovf pad atsign)
  1048.   (cond
  1049.    ((not (or w d))
  1050.     (prin1 number stream)
  1051.     nil)
  1052.    (t
  1053.     (let ((spaceleft w))
  1054.       (when (and w (or atsign (minusp number))) (decf spaceleft))
  1055.       (multiple-value-bind 
  1056.       (str len lpoint tpoint)
  1057.       (lisp::flonum-to-string (abs number) spaceleft d k)
  1058.     ;;if caller specifically requested no fraction digits, suppress the
  1059.     ;;optional trailing zero
  1060.     (when (and d (zerop d)) (setq tpoint nil))
  1061.     (when w 
  1062.       (decf spaceleft len)
  1063.       ;;optional leading zero
  1064.       (when lpoint
  1065.         (if (or (> spaceleft 0) tpoint) ;force at least one digit
  1066.         (decf spaceleft)
  1067.         (setq lpoint nil)))
  1068.       ;;optional trailing zero
  1069.       (when tpoint
  1070.         (if (> spaceleft 0)
  1071.         (decf spaceleft)
  1072.         (setq tpoint nil))))
  1073.     (cond ((and w (< spaceleft 0) ovf)
  1074.            ;;field width overflow
  1075.            (dotimes (i w) (write-char ovf stream))
  1076.            t)
  1077.           (t
  1078.            (when w (dotimes (i spaceleft) (write-char pad stream)))
  1079.            (if (minusp number)
  1080.            (write-char #\- stream)
  1081.            (if atsign (write-char #\+ stream)))
  1082.            (when lpoint (write-char #\0 stream))
  1083.            (write-string str stream)
  1084.            (when tpoint (write-char #\0 stream))
  1085.            nil)))))))
  1086.  
  1087. (def-format-directive #\E (colonp atsignp params)
  1088.   (when colonp
  1089.     (error 'format-error
  1090.        :complaint
  1091.        "Cannot specify the colon modifier with this directive."))
  1092.   (expand-bind-defaults
  1093.       ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
  1094.       params
  1095.     `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
  1096.              ,atsignp)))
  1097.  
  1098. (def-format-interpreter #\E (colonp atsignp params)
  1099.   (when colonp
  1100.     (error 'format-error
  1101.        :complaint
  1102.        "Cannot specify the colon modifier with this directive."))
  1103.   (interpret-bind-defaults
  1104.       ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
  1105.       params
  1106.     (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
  1107.  
  1108. (defun format-exponential (stream number w d e k ovf pad marker atsign)
  1109.   (if (floatp number)
  1110.       (format-exp-aux stream number w d e k ovf pad marker atsign)
  1111.       (if (rationalp number)
  1112.       (format-exp-aux stream
  1113.               (coerce number 'single-float)
  1114.               w d e k ovf pad marker atsign)
  1115.       (format-write-field stream
  1116.                   (decimal-string number)
  1117.                   w 1 0 #\space t))))
  1118.  
  1119. (defun format-exponent-marker (number)
  1120.   (if (typep number *read-default-float-format*)
  1121.       #\e
  1122.       (typecase number
  1123.     (single-float #\f)
  1124.     (double-float #\d)
  1125.     (short-float #\s)
  1126.     (long-float #\l))))
  1127.  
  1128. ;;;Here we prevent the scale factor from shifting all significance out of
  1129. ;;;a number to the right.  We allow insignificant zeroes to be shifted in
  1130. ;;;to the left right, athough it is an error to specify k and d such that this
  1131. ;;;occurs.  Perhaps we should detect both these condtions and flag them as
  1132. ;;;errors.  As for now, we let the user get away with it, and merely guarantee
  1133. ;;;that at least one significant digit will appear.
  1134.  
  1135. (defun format-exp-aux (stream number w d e k ovf pad marker atsign)
  1136.   (if (not (or w d))
  1137.       (prin1 number stream)
  1138.       (multiple-value-bind (num expt)
  1139.                (lisp::scale-exponent (abs number))
  1140.     (let* ((expt (- expt k))
  1141.            (estr (decimal-string (abs expt)))
  1142.            (elen (if e (max (length estr) e) (length estr)))
  1143.            (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
  1144.            (fmin (if (minusp k) (- 1 k) nil))
  1145.            (spaceleft (if w (- w 2 elen) nil)))
  1146.       (when (or atsign (minusp number)) (decf spaceleft))
  1147.       (if (and w ovf e (> elen e)) ;exponent overflow
  1148.           (dotimes (i w) (write-char ovf stream))
  1149.           (multiple-value-bind
  1150.           (fstr flen lpoint)
  1151.           (lisp::flonum-to-string num spaceleft fdig k fmin)
  1152.         (when w 
  1153.           (decf spaceleft flen)
  1154.           (when lpoint
  1155.             (if (> spaceleft 0)
  1156.             (decf spaceleft)
  1157.             (setq lpoint nil))))
  1158.         (cond ((and w (< spaceleft 0) ovf)
  1159.                ;;significand overflow
  1160.                (dotimes (i w) (write-char ovf stream)))
  1161.               (t (when w
  1162.                (dotimes (i spaceleft) (write-char pad stream)))
  1163.              (if (minusp number)
  1164.                  (write-char #\- stream)
  1165.                  (if atsign (write-char #\+ stream)))
  1166.              (when lpoint (write-char #\0 stream))
  1167.              (write-string fstr stream)
  1168.              (write-char (if marker
  1169.                      marker
  1170.                      (format-exponent-marker number))
  1171.                      stream)
  1172.              (write-char (if (minusp expt) #\- #\+) stream)
  1173.              (when e 
  1174.                ;;zero-fill before exponent if necessary
  1175.                (dotimes (i (- e (length estr)))
  1176.                  (write-char #\0 stream)))
  1177.              (write-string estr stream)))))))))
  1178.  
  1179. (def-format-directive #\G (colonp atsignp params)
  1180.   (when colonp
  1181.     (error 'format-error
  1182.        :complaint
  1183.        "Cannot specify the colon modifier with this directive."))
  1184.   (expand-bind-defaults
  1185.       ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
  1186.       params
  1187.     `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
  1188.  
  1189. (def-format-interpreter #\G (colonp atsignp params)
  1190.   (when colonp
  1191.     (error 'format-error
  1192.        :complaint
  1193.        "Cannot specify the colon modifier with this directive."))
  1194.   (interpret-bind-defaults
  1195.       ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
  1196.       params
  1197.     (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
  1198.  
  1199. (defun format-general (stream number w d e k ovf pad marker atsign)
  1200.   ;;The Excelsior edition does not say what to do if
  1201.   ;;the argument is not a float.  Here, we adopt the
  1202.   ;;conventions used by ~F and ~E.
  1203.   (if (floatp number)
  1204.       (format-general-aux stream number w d e k ovf pad marker atsign)
  1205.       (if (rationalp number)
  1206.       (format-general-aux stream
  1207.                   (coerce number 'single-float)
  1208.                   w d e k ovf pad marker atsign)
  1209.       (format-write-field stream
  1210.                   (decimal-string number)
  1211.                   w 1 0 #\space t))))
  1212.  
  1213. (defun format-general-aux (stream number w d e k ovf pad marker atsign)
  1214.   (multiple-value-bind (ignore n) 
  1215.                (lisp::scale-exponent (abs number))
  1216.     (declare (ignore ignore))
  1217.     ;;Default d if omitted.  The procedure is taken directly
  1218.     ;;from the definition given in the manual, and is not
  1219.     ;;very efficient, since we generate the digits twice.
  1220.     ;;Future maintainers are encouraged to improve on this.
  1221.     (unless d
  1222.       (multiple-value-bind (str len) 
  1223.                (lisp::flonum-to-string (abs number))
  1224.     (declare (ignore str))
  1225.     (let ((q (if (= len 1) 1 (1- len))))
  1226.       (setq d (max q (min n 7))))))
  1227.     (let* ((ee (if e (+ e 2) 4))
  1228.        (ww (if w (- w ee) nil))
  1229.        (dd (- d n)))
  1230.       (cond ((<= 0 dd d)
  1231.          (let ((char (if (format-fixed-aux stream number ww dd nil
  1232.                            ovf pad atsign)
  1233.                  ovf
  1234.                  #\space)))
  1235.            (dotimes (i ee) (write-char char stream))))
  1236.         (t
  1237.          (format-exp-aux stream number w d e (or k 1)
  1238.                  ovf pad marker atsign))))))
  1239.  
  1240. (def-format-directive #\$ (colonp atsignp params)
  1241.   (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
  1242.     `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
  1243.              ,atsignp)))
  1244.  
  1245. (def-format-interpreter #\$ (colonp atsignp params)
  1246.   (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
  1247.     (format-dollars stream (next-arg) d n w pad colonp atsignp)))
  1248.  
  1249. (defun format-dollars (stream number d n w pad colon atsign)
  1250.   (if (rationalp number) (setq number (coerce number 'single-float)))
  1251.   (if (floatp number)
  1252.       (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
  1253.          (signlen (length signstr)))
  1254.     (multiple-value-bind (str strlen ig2 ig3 pointplace)
  1255.                  (lisp::flonum-to-string number nil d nil)
  1256.       (declare (ignore ig2 ig3))
  1257.       (when colon (write-string signstr stream))
  1258.       (dotimes (i (- w signlen (- n pointplace) strlen))
  1259.         (write-char pad stream))
  1260.       (unless colon (write-string signstr stream))
  1261.       (dotimes (i (- n pointplace)) (write-char #\0 stream))
  1262.       (write-string str stream)))
  1263.       (format-write-field stream
  1264.               (decimal-string number)
  1265.               w 1 0 #\space t)))
  1266.  
  1267.  
  1268. ;;;; line/page breaks and other stuff like that.
  1269.  
  1270. (def-format-directive #\% (colonp atsignp params)
  1271.   (when (or colonp atsignp)
  1272.     (error 'format-error
  1273.        :complaint
  1274.        "Cannot specify either colon or atsign for this directive."))
  1275.   (if params
  1276.       (expand-bind-defaults ((count 1)) params
  1277.     `(dotimes (i ,count)
  1278.        (terpri stream)))
  1279.       '(terpri stream)))
  1280.  
  1281. (def-format-interpreter #\% (colonp atsignp params)
  1282.   (when (or colonp atsignp)
  1283.     (error 'format-error
  1284.        :complaint
  1285.        "Cannot specify either colon or atsign for this directive."))
  1286.   (interpret-bind-defaults ((count 1)) params
  1287.     (dotimes (i count)
  1288.       (terpri stream))))
  1289.  
  1290. (def-format-directive #\& (colonp atsignp params)
  1291.   (when (or colonp atsignp)
  1292.     (error 'format-error
  1293.        :complaint
  1294.        "Cannot specify either colon or atsign for this directive."))
  1295.   (if params
  1296.       (expand-bind-defaults ((count 1)) params
  1297.     `(progn
  1298.        (fresh-line stream)
  1299.        (dotimes (i (1- ,count))
  1300.          (terpri stream))))
  1301.       '(fresh-line stream)))
  1302.  
  1303. (def-format-interpreter #\& (colonp atsignp params)
  1304.   (when (or colonp atsignp)
  1305.     (error 'format-error
  1306.        :complaint
  1307.        "Cannot specify either colon or atsign for this directive."))
  1308.   (interpret-bind-defaults ((count 1)) params
  1309.     (fresh-line stream)
  1310.     (dotimes (i (1- count))
  1311.       (terpri stream))))
  1312.  
  1313. (def-format-directive #\| (colonp atsignp params)
  1314.   (when (or colonp atsignp)
  1315.     (error 'format-error
  1316.        :complaint
  1317.        "Cannot specify either colon or atsign for this directive."))
  1318.   (if params
  1319.       (expand-bind-defaults ((count 1)) params
  1320.     `(dotimes (i ,count)
  1321.        (write-char #\page stream)))
  1322.       '(write-char #\page stream)))
  1323.  
  1324. (def-format-interpreter #\| (colonp atsignp params)
  1325.   (when (or colonp atsignp)
  1326.     (error 'format-error
  1327.        :complaint
  1328.        "Cannot specify either colon or atsign for this directive."))
  1329.   (interpret-bind-defaults ((count 1)) params
  1330.     (dotimes (i count)
  1331.       (write-char #\page stream))))
  1332.  
  1333. (def-format-directive #\~ (colonp atsignp params)
  1334.   (when (or colonp atsignp)
  1335.     (error 'format-error
  1336.        :complaint
  1337.        "Cannot specify either colon or atsign for this directive."))
  1338.   (if params
  1339.       (expand-bind-defaults ((count 1)) params
  1340.     `(dotimes (i ,count)
  1341.        (write-char #\~ stream)))
  1342.       '(write-char #\~ stream)))
  1343.  
  1344. (def-format-interpreter #\~ (colonp atsignp params)
  1345.   (when (or colonp atsignp)
  1346.     (error 'format-error
  1347.        :complaint
  1348.        "Cannot specify either colon or atsign for this directive."))
  1349.   (interpret-bind-defaults ((count 1)) params
  1350.     (dotimes (i count)
  1351.       (write-char #\~ stream))))
  1352.  
  1353. (def-complex-format-directive #\newline (colonp atsignp params directives)
  1354.   (when (and colonp atsignp)
  1355.     (error 'format-error
  1356.        :complaint
  1357.        "Cannot specify both colon and atsign for this directive."))
  1358.   (values (expand-bind-defaults () params
  1359.         (if atsignp
  1360.         '(write-char #\newline stream)
  1361.         nil))
  1362.       (if (and (not colonp)
  1363.            directives
  1364.            (simple-string-p (car directives)))
  1365.           (cons (string-left-trim '(#\space #\newline #\tab)
  1366.                       (car directives))
  1367.             (cdr directives))
  1368.           directives)))
  1369.  
  1370. (def-complex-format-interpreter #\newline (colonp atsignp params directives)
  1371.   (when (and colonp atsignp)
  1372.     (error 'format-error
  1373.        :complaint
  1374.        "Cannot specify both colon and atsign for this directive."))
  1375.   (interpret-bind-defaults () params
  1376.     (when atsignp
  1377.       (write-char #\newline stream)))
  1378.   (if (and (not colonp)
  1379.        directives
  1380.        (simple-string-p (car directives)))
  1381.       (cons (string-left-trim '(#\space #\newline #\tab)
  1382.                   (car directives))
  1383.         (cdr directives))
  1384.       directives))
  1385.  
  1386.  
  1387. ;;;; Tab and simple pretty-printing noise.
  1388.  
  1389. (def-format-directive #\T (colonp atsignp params)
  1390.   (if colonp
  1391.       (expand-bind-defaults ((n 1) (m 1)) params
  1392.     `(pprint-tab ,(if atsignp :section-relative :section)
  1393.              ,n ,m stream))
  1394.       (if atsignp
  1395.       (expand-bind-defaults ((colrel 1) (colinc 1)) params
  1396.         `(format-relative-tab stream ,colrel ,colinc))
  1397.       (expand-bind-defaults ((colnum 1) (colinc 1)) params
  1398.         `(format-absolute-tab stream ,colnum ,colinc)))))
  1399.  
  1400. (def-format-interpreter #\T (colonp atsignp params)
  1401.   (if colonp
  1402.       (interpret-bind-defaults ((n 1) (m 1)) params
  1403.     (pprint-tab (if atsignp :section-relative :section) n m stream))
  1404.       (if atsignp
  1405.       (interpret-bind-defaults ((colrel 1) (colinc 1)) params
  1406.         (format-relative-tab stream colrel colinc))
  1407.       (interpret-bind-defaults ((colnum 1) (colinc 1)) params
  1408.         (format-absolute-tab stream colnum colinc)))))
  1409.  
  1410. (defun output-spaces (stream n)
  1411.   (let ((spaces #.(make-string 100 :initial-element #\space)))
  1412.     (loop
  1413.       (when (< n (length spaces))
  1414.     (return))
  1415.       (write-string spaces stream)
  1416.       (decf n (length spaces)))
  1417.     (write-string spaces stream :end n)))
  1418.  
  1419. (defun format-relative-tab (stream colrel colinc)
  1420.   (if (pp:pretty-stream-p stream)
  1421.       (pprint-tab :line-relative colrel colinc stream)
  1422.       (let* ((cur (lisp::charpos stream))
  1423.          (spaces (if (and cur (plusp colinc))
  1424.              (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
  1425.              colrel)))
  1426.     (output-spaces stream spaces))))
  1427.  
  1428. (defun format-absolute-tab (stream colnum colinc)
  1429.   (if (pp:pretty-stream-p stream)
  1430.       (pprint-tab :line colnum colinc stream)
  1431.       (let ((cur (lisp::charpos stream)))
  1432.     (cond ((null cur)
  1433.            (write-string "  " stream))
  1434.           ((< cur colnum)
  1435.            (output-spaces stream (- colnum cur)))
  1436.           (t
  1437.            (unless (zerop colinc)
  1438.          (output-spaces stream (- colinc (rem cur colinc)))))))))
  1439.  
  1440. (def-format-directive #\_ (colonp atsignp params)
  1441.   (expand-bind-defaults () params
  1442.     `(pprint-newline ,(if colonp
  1443.               (if atsignp
  1444.                   :mandatory
  1445.                   :fill)
  1446.               (if atsignp
  1447.                   :miser
  1448.                   :linear))
  1449.              stream)))
  1450.  
  1451. (def-format-interpreter #\_ (colonp atsignp params)
  1452.   (interpret-bind-defaults () params
  1453.     (pprint-newline (if colonp
  1454.             (if atsignp
  1455.                 :mandatory
  1456.                 :fill)
  1457.             (if atsignp
  1458.                 :miser
  1459.                 :linear))
  1460.             stream)))
  1461.  
  1462. (def-format-directive #\I (colonp atsignp params)
  1463.   (when atsignp
  1464.     (error 'format-error
  1465.        :complaint "Cannot specify the at-sign modifier."))
  1466.   (expand-bind-defaults ((n 0)) params
  1467.     `(pprint-indent ,(if colonp :current :block) ,n stream)))
  1468.  
  1469. (def-format-interpreter #\I (colonp atsignp params)
  1470.   (when atsignp
  1471.     (error 'format-error
  1472.        :complaint "Cannot specify the at-sign modifier."))
  1473.   (interpret-bind-defaults ((n 0)) params
  1474.     (pprint-indent (if colonp :current :block) n stream)))
  1475.  
  1476.  
  1477. ;;;; *
  1478.  
  1479. (def-format-directive #\* (colonp atsignp params end)
  1480.   (if atsignp
  1481.       (if colonp
  1482.       (error 'format-error
  1483.          :complaint "Cannot specify both colon and at-sign.")
  1484.       (expand-bind-defaults ((posn 0)) params
  1485.         (unless *orig-args-available*
  1486.           (throw 'need-orig-args nil))
  1487.         `(if (<= 0 ,posn (length orig-args))
  1488.          (setf args (nthcdr ,posn orig-args))
  1489.          (error 'format-error
  1490.             :complaint "Index ~D out of bounds.  Should have been ~
  1491.                     between 0 and ~D."
  1492.             :arguments (list ,posn (length orig-args))
  1493.             :offset ,(1- end)))))
  1494.       (if colonp
  1495.       (expand-bind-defaults ((n 1)) params
  1496.         (unless *orig-args-available*
  1497.           (throw 'need-orig-args nil))
  1498.         `(do ((cur-posn 0 (1+ cur-posn))
  1499.           (arg-ptr orig-args (cdr arg-ptr)))
  1500.          ((eq arg-ptr args)
  1501.           (let ((new-posn (- cur-posn ,n)))
  1502.             (if (<= 0 new-posn (length orig-args))
  1503.             (setf args (nthcdr new-posn orig-args))
  1504.             (error 'format-error
  1505.                    :complaint
  1506.                    "Index ~D out of bounds.  Should have been ~
  1507.                 between 0 and ~D."
  1508.                    :arguments
  1509.                    (list new-posn (length orig-args))
  1510.                    :offset ,(1- end)))))))
  1511.       (if params
  1512.           (expand-bind-defaults ((n 1)) params
  1513.         (setf *only-simple-args* nil)
  1514.         `(dotimes (i ,n)
  1515.            ,(expand-next-arg)))
  1516.           (expand-next-arg)))))
  1517.  
  1518. (def-format-interpreter #\* (colonp atsignp params)
  1519.   (if atsignp
  1520.       (if colonp
  1521.       (error 'format-error
  1522.          :complaint "Cannot specify both colon and at-sign.")
  1523.       (interpret-bind-defaults ((posn 0)) params
  1524.         (if (<= 0 posn (length orig-args))
  1525.         (setf args (nthcdr posn orig-args))
  1526.         (error 'format-error
  1527.                :complaint "Index ~D out of bounds.  Should have been ~
  1528.                    between 0 and ~D."
  1529.                :arguments (list posn (length orig-args))))))
  1530.       (if colonp
  1531.       (interpret-bind-defaults ((n 1)) params
  1532.         (do ((cur-posn 0 (1+ cur-posn))
  1533.          (arg-ptr orig-args (cdr arg-ptr)))
  1534.         ((eq arg-ptr args)
  1535.          (let ((new-posn (- cur-posn n)))
  1536.            (if (<= 0 new-posn (length orig-args))
  1537.                (setf args (nthcdr new-posn orig-args))
  1538.                (error 'format-error
  1539.                   :complaint
  1540.                   "Index ~D out of bounds.  Should have been ~
  1541.                    between 0 and ~D."
  1542.                   :arguments
  1543.                   (list new-posn (length orig-args))))))))
  1544.       (interpret-bind-defaults ((n 1)) params
  1545.         (dotimes (i n)
  1546.           (next-arg))))))
  1547.  
  1548.  
  1549. ;;;; Indirection.
  1550.  
  1551. (def-format-directive #\? (colonp atsignp params string end)
  1552.   (when colonp
  1553.     (error 'format-error
  1554.        :complaint "Cannot specify the colon modifier."))
  1555.   (expand-bind-defaults () params
  1556.     `(handler-bind
  1557.      ((format-error
  1558.        #'(lambda (condition)
  1559.            (error 'format-error
  1560.               :complaint
  1561.               "~A~%while processing indirect format string:"
  1562.               :arguments (list condition)
  1563.               :print-banner nil
  1564.               :control-string ,string
  1565.               :offset ,(1- end)))))
  1566.        ,(if atsignp
  1567.         (if *orig-args-available*
  1568.         `(setf args (%format stream ,(expand-next-arg) orig-args args))
  1569.         (throw 'need-orig-args nil))
  1570.         `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
  1571.  
  1572. (def-format-interpreter #\? (colonp atsignp params string end)
  1573.   (when colonp
  1574.     (error 'format-error
  1575.        :complaint "Cannot specify the colon modifier."))
  1576.   (interpret-bind-defaults () params
  1577.     (handler-bind
  1578.     ((format-error
  1579.       #'(lambda (condition)
  1580.           (error 'format-error
  1581.              :complaint
  1582.              "~A~%while processing indirect format string:"
  1583.              :arguments (list condition)
  1584.              :print-banner nil
  1585.              :control-string string
  1586.              :offset (1- end)))))
  1587.       (if atsignp
  1588.       (setf args (%format stream (next-arg) orig-args args))
  1589.       (%format stream (next-arg) (next-arg))))))
  1590.  
  1591.  
  1592. ;;;; Capitalization.
  1593.  
  1594. (def-complex-format-directive #\( (colonp atsignp params directives)
  1595.   (let ((close (find-directive directives #\) nil)))
  1596.     (unless close
  1597.       (error 'format-error
  1598.          :complaint "No corresponding close paren."))
  1599.     (let* ((posn (position close directives))
  1600.        (before (subseq directives 0 posn))
  1601.        (after (nthcdr (1+ posn) directives)))
  1602.       (values
  1603.        (expand-bind-defaults () params
  1604.      `(let ((stream (make-case-frob-stream stream
  1605.                            ,(if colonp
  1606.                             (if atsignp
  1607.                             :upcase
  1608.                             :capitalize)
  1609.                             (if atsignp
  1610.                             :capitalize-first
  1611.                             :downcase)))))
  1612.         ,@(expand-directive-list before)))
  1613.        after))))
  1614.  
  1615. (def-complex-format-interpreter #\( (colonp atsignp params directives)
  1616.   (let ((close (find-directive directives #\) nil)))
  1617.     (unless close
  1618.       (error 'format-error
  1619.          :complaint "No corresponding close paren."))
  1620.     (interpret-bind-defaults () params
  1621.       (let* ((posn (position close directives))
  1622.          (before (subseq directives 0 posn))
  1623.          (after (nthcdr (1+ posn) directives))
  1624.          (stream (make-case-frob-stream stream
  1625.                         (if colonp
  1626.                         (if atsignp
  1627.                             :upcase
  1628.                             :capitalize)
  1629.                         (if atsignp
  1630.                             :capitalize-first
  1631.                             :downcase)))))
  1632.     (setf args (interpret-directive-list stream before orig-args args))
  1633.     after))))
  1634.  
  1635. (def-complex-format-directive #\) ()
  1636.   (error 'format-error
  1637.      :complaint "No corresponding open paren."))
  1638.  
  1639. (def-complex-format-interpreter #\) ()
  1640.   (error 'format-error
  1641.      :complaint "No corresponding open paren."))
  1642.  
  1643.  
  1644. ;;;; Conditionals
  1645.  
  1646. (defun parse-conditional-directive (directives)
  1647.   (let ((sublists nil)
  1648.     (last-semi-with-colon-p nil)
  1649.     (remaining directives))
  1650.     (loop
  1651.       (let ((close-or-semi (find-directive remaining #\] t)))
  1652.     (unless close-or-semi
  1653.       (error 'format-error
  1654.          :complaint "No corresponding close bracket."))
  1655.     (let ((posn (position close-or-semi remaining)))
  1656.       (push (subseq remaining 0 posn) sublists)
  1657.       (setf remaining (nthcdr (1+ posn) remaining))
  1658.       (when (char= (format-directive-character close-or-semi) #\])
  1659.         (return))
  1660.       (setf last-semi-with-colon-p
  1661.         (format-directive-colonp close-or-semi)))))
  1662.     (values sublists last-semi-with-colon-p remaining)))
  1663.  
  1664. (def-complex-format-directive #\[ (colonp atsignp params directives)
  1665.   (multiple-value-bind
  1666.       (sublists last-semi-with-colon-p remaining)
  1667.       (parse-conditional-directive directives)
  1668.     (values
  1669.      (if atsignp
  1670.      (if colonp
  1671.          (error 'format-error
  1672.             :complaint
  1673.             "Cannot specify both the colon and at-sign modifiers.")
  1674.          (if (cdr sublists)
  1675.          (error 'format-error
  1676.             :complaint
  1677.             "Can only specify one section")
  1678.          (expand-bind-defaults () params
  1679.            (expand-maybe-conditional (car sublists)))))
  1680.      (if colonp
  1681.          (if (= (length sublists) 2)
  1682.          (expand-bind-defaults () params
  1683.            (expand-true-false-conditional (car sublists)
  1684.                           (cadr sublists)))
  1685.          (error 'format-error
  1686.             :complaint
  1687.             "Must specify exactly two sections."))
  1688.          (expand-bind-defaults ((index (expand-next-arg))) params
  1689.            (setf *only-simple-args* nil)
  1690.            (let ((clauses nil))
  1691.          (when last-semi-with-colon-p
  1692.            (push `(t ,@(expand-directive-list (pop sublists)))
  1693.              clauses))
  1694.          (let ((count (length sublists)))
  1695.            (dolist (sublist sublists)
  1696.              (push `(,(decf count)
  1697.                  ,@(expand-directive-list sublist))
  1698.                clauses)))
  1699.          `(case ,index ,@clauses)))))
  1700.      remaining)))
  1701.  
  1702. (defun expand-maybe-conditional (sublist)
  1703.   (flet ((hairy ()
  1704.        `(let ((prev-args args)
  1705.           (arg ,(expand-next-arg)))
  1706.           (when arg
  1707.         (setf args prev-args)
  1708.         ,@(expand-directive-list sublist)))))
  1709.     (if *only-simple-args*
  1710.     (multiple-value-bind
  1711.         (guts new-args)
  1712.         (let ((*simple-args* *simple-args*))
  1713.           (values (expand-directive-list sublist)
  1714.               *simple-args*))
  1715.       (cond ((eq *simple-args* (cdr new-args))
  1716.          (setf *simple-args* new-args)
  1717.          `(when ,(caar new-args)
  1718.             ,@guts))
  1719.         (t
  1720.          (setf *only-simple-args* nil)
  1721.          (hairy))))
  1722.     (hairy))))
  1723.  
  1724. (defun expand-true-false-conditional (true false)
  1725.   (let ((arg (expand-next-arg)))
  1726.     (flet ((hairy ()
  1727.          `(if ,arg
  1728.           (progn
  1729.             ,@(expand-directive-list true))
  1730.           (progn
  1731.             ,@(expand-directive-list false)))))
  1732.       (if *only-simple-args*
  1733.       (multiple-value-bind
  1734.           (true-guts true-args true-simple)
  1735.           (let ((*simple-args* *simple-args*)
  1736.             (*only-simple-args* t))
  1737.         (values (expand-directive-list true)
  1738.             *simple-args*
  1739.             *only-simple-args*))
  1740.         (multiple-value-bind
  1741.         (false-guts false-args false-simple)
  1742.         (let ((*simple-args* *simple-args*)
  1743.               (*only-simple-args* t))
  1744.           (values (expand-directive-list false)
  1745.               *simple-args*
  1746.               *only-simple-args*))
  1747.           (if (= (length true-args) (length false-args))
  1748.           `(if ,arg
  1749.                (progn
  1750.              ,@true-guts)
  1751.                ,(do ((false false-args (cdr false))
  1752.                  (true true-args (cdr true))
  1753.                  (bindings nil (cons `(,(caar false) ,(caar true))
  1754.                          bindings)))
  1755.                 ((eq true *simple-args*)
  1756.                  (setf *simple-args* true-args)
  1757.                  (setf *only-simple-args*
  1758.                    (and true-simple false-simple))
  1759.                  (if bindings
  1760.                  `(let ,bindings
  1761.                     ,@false-guts)
  1762.                  `(progn
  1763.                     ,@false-guts)))))
  1764.           (progn
  1765.             (setf *only-simple-args* nil)
  1766.             (hairy)))))
  1767.       (hairy)))))
  1768.  
  1769.  
  1770.  
  1771. (def-complex-format-interpreter #\[ (colonp atsignp params directives)
  1772.   (multiple-value-bind
  1773.       (sublists last-semi-with-colon-p remaining)
  1774.       (parse-conditional-directive directives)
  1775.     (setf args
  1776.       (if atsignp
  1777.           (if colonp
  1778.           (error 'format-error
  1779.              :complaint
  1780.              "Cannot specify both the colon and at-sign modifiers.")
  1781.           (if (cdr sublists)
  1782.               (error 'format-error
  1783.                  :complaint
  1784.                  "Can only specify one section")
  1785.               (interpret-bind-defaults () params
  1786.             (let ((prev-args args)
  1787.                   (arg (next-arg)))
  1788.               (if arg
  1789.                   (interpret-directive-list stream
  1790.                             (car sublists)
  1791.                             orig-args
  1792.                             prev-args)
  1793.                   args)))))
  1794.           (if colonp
  1795.           (if (= (length sublists) 2)
  1796.               (interpret-bind-defaults () params
  1797.             (if (next-arg)
  1798.                 (interpret-directive-list stream (car sublists)
  1799.                               orig-args args)
  1800.                 (interpret-directive-list stream (cadr sublists)
  1801.                               orig-args args)))
  1802.               (error 'format-error
  1803.                  :complaint
  1804.                  "Must specify exactly two sections."))
  1805.           (interpret-bind-defaults ((index (next-arg))) params
  1806.             (let* ((default (and last-semi-with-colon-p
  1807.                      (pop sublists)))
  1808.                (last (1- (length sublists)))
  1809.                (sublist
  1810.                 (if (<= 0 index last)
  1811.                 (nth (- last index) sublists)
  1812.                 default)))
  1813.               (interpret-directive-list stream sublist orig-args
  1814.                         args))))))
  1815.     remaining))
  1816.  
  1817. (def-complex-format-directive #\; ()
  1818.   (error 'format-error
  1819.      :complaint
  1820.      "~~; not contained within either ~~[...~~] or ~~<...~~>."))
  1821.  
  1822. (def-complex-format-interpreter #\; ()
  1823.   (error 'format-error
  1824.      :complaint
  1825.      "~~; not contained within either ~~[...~~] or ~~<...~~>."))
  1826.  
  1827. (def-complex-format-interpreter #\] ()
  1828.   (error 'format-error
  1829.      :complaint
  1830.      "No corresponding open bracket."))
  1831.  
  1832. (def-complex-format-directive #\] ()
  1833.   (error 'format-error
  1834.      :complaint
  1835.      "No corresponding open bracket."))
  1836.  
  1837.  
  1838. ;;;; Up-and-out.
  1839.  
  1840. (defvar *outside-args*)
  1841.  
  1842. (def-format-directive #\^ (colonp atsignp params)
  1843.   (when atsignp
  1844.     (error 'format-error
  1845.        :complaint "Cannot specify the at-sign modifier."))
  1846.   (when (and colonp (not *up-up-and-out-allowed*))
  1847.     (error 'format-error
  1848.        :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct."))
  1849.   `(when ,(case (length params)
  1850.         (0 (if colonp
  1851.            '(null outside-args)
  1852.            (progn
  1853.              (setf *only-simple-args* nil)
  1854.              '(null args))))
  1855.         (1 (expand-bind-defaults ((count 0)) params
  1856.          `(zerop ,count)))
  1857.         (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
  1858.          `(= ,arg1 ,arg2)))
  1859.         (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
  1860.          `(<= ,arg1 ,arg2 ,arg3))))
  1861.      ,(if colonp
  1862.       '(return-from outside-loop nil)
  1863.       '(return))))
  1864.  
  1865. (def-format-interpreter #\^ (colonp atsignp params)
  1866.   (when atsignp
  1867.     (error 'format-error
  1868.        :complaint "Cannot specify the at-sign modifier."))
  1869.   (when (and colonp (not *up-up-and-out-allowed*))
  1870.     (error 'format-error
  1871.        :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct."))
  1872.   (when (case (length params)
  1873.       (0 (if colonp
  1874.          (null *outside-args*)
  1875.          (null args)))
  1876.       (1 (interpret-bind-defaults ((count 0)) params
  1877.            (zerop count)))
  1878.       (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params
  1879.            (= arg1 arg2)))
  1880.       (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
  1881.            (<= arg1 arg2 arg3))))
  1882.     (throw (if colonp 'up-up-and-out 'up-and-out)
  1883.        args)))
  1884.  
  1885.  
  1886. ;;;; Iteration.
  1887.  
  1888. (def-complex-format-directive #\{ (colonp atsignp params string end directives)
  1889.   (let ((close (find-directive directives #\} nil)))
  1890.     (unless close
  1891.       (error 'format-error
  1892.          :complaint
  1893.          "No corresponding close brace."))
  1894.     (let* ((closed-with-colon (format-directive-colonp close))
  1895.        (posn (position close directives)))
  1896.       (labels
  1897.       ((compute-insides ()
  1898.          (if (zerop posn)
  1899.          (if *orig-args-available*
  1900.              `((handler-bind
  1901.                ((format-error
  1902.                  #'(lambda (condition)
  1903.                  (error 'format-error
  1904.                     :complaint
  1905.             "~A~%while processing indirect format string:"
  1906.                     :arguments (list condition)
  1907.                     :print-banner nil
  1908.                     :control-string ,string
  1909.                     :offset ,(1- end)))))
  1910.              (setf args
  1911.                    (%format stream inside-string orig-args args))))
  1912.              (throw 'need-orig-args nil))
  1913.          (let ((*up-up-and-out-allowed* colonp))
  1914.            (expand-directive-list (subseq directives 0 posn)))))
  1915.        (compute-loop-aux (count)
  1916.          (when atsignp
  1917.            (setf *only-simple-args* nil))
  1918.          `(loop
  1919.         ,@(unless closed-with-colon
  1920.             '((when (null args)
  1921.             (return))))
  1922.         ,@(when count
  1923.             `((when (and ,count (minusp (decf ,count)))
  1924.             (return))))
  1925.         ,@(if colonp
  1926.               (let ((*expander-next-arg-macro* 'expander-next-arg)
  1927.                 (*only-simple-args* nil)
  1928.                 (*orig-args-available* t))
  1929.             `((let* ((orig-args ,(expand-next-arg))
  1930.                  (outside-args args)
  1931.                  (args orig-args))
  1932.                 (declare (ignorable orig-args outside-args args))
  1933.                 (block nil
  1934.                   ,@(compute-insides)))))
  1935.               (compute-insides))
  1936.         ,@(when closed-with-colon
  1937.             '((when (null args)
  1938.             (return))))))
  1939.        (compute-loop ()
  1940.          (if params
  1941.          (expand-bind-defaults ((count nil)) params
  1942.            (compute-loop-aux count))
  1943.          (compute-loop-aux nil)))
  1944.        (compute-block ()
  1945.          (if colonp
  1946.          `(block outside-loop
  1947.             ,(compute-loop))
  1948.          (compute-loop)))
  1949.        (compute-bindings ()
  1950.          (if atsignp
  1951.          (compute-block)
  1952.          `(let* ((orig-args ,(expand-next-arg))
  1953.              (args orig-args))
  1954.             (declare (ignorable orig-args args))
  1955.             ,(let ((*expander-next-arg-macro* 'expander-next-arg)
  1956.                (*only-simple-args* nil)
  1957.                (*orig-args-available* t))
  1958.                (compute-block))))))
  1959.     (values (if (zerop posn)
  1960.             `(let ((inside-string ,(expand-next-arg)))
  1961.                ,(compute-bindings))
  1962.             (compute-bindings))
  1963.         (nthcdr (1+ posn) directives))))))
  1964.  
  1965. (def-complex-format-interpreter #\{
  1966.                 (colonp atsignp params string end directives)
  1967.   (let ((close (find-directive directives #\} nil)))
  1968.     (unless close
  1969.       (error 'format-error
  1970.          :complaint
  1971.          "No corresponding close brace."))
  1972.     (interpret-bind-defaults ((max-count nil)) params
  1973.       (let* ((closed-with-colon (format-directive-colonp close))
  1974.          (posn (position close directives))
  1975.          (insides (if (zerop posn)
  1976.               (next-arg)
  1977.               (subseq directives 0 posn)))
  1978.          (*up-up-and-out-allowed* colonp))
  1979.     (labels
  1980.         ((do-guts (orig-args args)
  1981.            (if (zerop posn)
  1982.            (handler-bind
  1983.                ((format-error
  1984.              #'(lambda (condition)
  1985.                  (error 'format-error
  1986.                     :complaint
  1987.                 "~A~%while processing indirect format string:"
  1988.                     :arguments (list condition)
  1989.                     :print-banner nil
  1990.                     :control-string string
  1991.                     :offset (1- end)))))
  1992.              (%format stream insides orig-args args))
  1993.            (interpret-directive-list stream insides
  1994.                          orig-args args)))
  1995.          (bind-args (orig-args args)
  1996.            (if colonp
  1997.            (let* ((arg (next-arg))
  1998.               (*logical-block-popper* nil)
  1999.               (*outside-args* args))
  2000.              (catch 'up-and-out
  2001.                (do-guts arg arg)
  2002.                args))
  2003.            (do-guts orig-args args)))
  2004.          (do-loop (orig-args args)
  2005.            (catch (if colonp 'up-up-and-out 'up-and-out)
  2006.          (loop
  2007.            (when (and (not closed-with-colon) (null args))
  2008.              (return))
  2009.            (when (and max-count (minusp (decf max-count)))
  2010.              (return))
  2011.            (setf args (bind-args orig-args args))
  2012.            (when (and closed-with-colon (null args))
  2013.              (return)))
  2014.          args)))
  2015.       (if atsignp
  2016.           (setf args (do-loop orig-args args))
  2017.           (let ((arg (next-arg))
  2018.             (*logical-block-popper* nil))
  2019.         (do-loop arg arg)))
  2020.       (nthcdr (1+ posn) directives))))))
  2021.  
  2022. (def-complex-format-directive #\} ()
  2023.   (error 'format-error
  2024.      :complaint "No corresponding open brace."))
  2025.  
  2026. (def-complex-format-interpreter #\} ()
  2027.   (error 'format-error
  2028.      :complaint "No corresponding open brace."))
  2029.  
  2030.  
  2031.  
  2032. ;;;; Justification.
  2033.  
  2034. (def-complex-format-directive #\< (colonp atsignp params string end directives)
  2035.   (multiple-value-bind
  2036.       (segments first-semi close remaining)
  2037.       (parse-format-justification directives)
  2038.     (values
  2039.      (if (format-directive-colonp close)
  2040.      (multiple-value-bind
  2041.          (prefix per-line-p insides suffix)
  2042.          (parse-format-logical-block segments colonp first-semi
  2043.                      close params string end)
  2044.        (expand-format-logical-block prefix per-line-p insides
  2045.                     suffix atsignp))
  2046.      (expand-format-justification segments colonp atsignp
  2047.                       first-semi params))
  2048.      remaining)))
  2049.  
  2050. (def-complex-format-interpreter #\<
  2051.                 (colonp atsignp params string end directives)
  2052.   (multiple-value-bind
  2053.       (segments first-semi close remaining)
  2054.       (parse-format-justification directives)
  2055.     (setf args
  2056.       (if (format-directive-colonp close)
  2057.           (multiple-value-bind
  2058.           (prefix per-line-p insides suffix)
  2059.           (parse-format-logical-block segments colonp first-semi
  2060.                           close params string end)
  2061.         (interpret-format-logical-block stream orig-args args
  2062.                         prefix per-line-p insides
  2063.                         suffix atsignp))
  2064.           (interpret-format-justification stream orig-args args
  2065.                           segments colonp atsignp
  2066.                           first-semi params)))
  2067.     remaining))
  2068.  
  2069. (defun parse-format-justification (directives)
  2070.   (let ((first-semi nil)
  2071.     (close nil)
  2072.     (remaining directives))
  2073.     (collect ((segments))
  2074.       (loop
  2075.     (let ((close-or-semi (find-directive remaining #\> t)))
  2076.       (unless close-or-semi
  2077.         (error 'format-error
  2078.            :complaint "No corresponding close bracket."))
  2079.       (let ((posn (position close-or-semi remaining)))
  2080.         (segments (subseq remaining 0 posn))
  2081.         (setf remaining (nthcdr (1+ posn) remaining)))
  2082.       (when (char= (format-directive-character close-or-semi)
  2083.                #\>)
  2084.         (setf close close-or-semi)
  2085.         (return))
  2086.       (unless first-semi
  2087.         (setf first-semi close-or-semi))))
  2088.       (values (segments) first-semi close remaining))))
  2089.  
  2090. (defun expand-format-justification (segments colonp atsignp first-semi params)
  2091.   (let ((newline-segment-p
  2092.      (and first-semi
  2093.           (format-directive-colonp first-semi))))
  2094.     (expand-bind-defaults
  2095.     ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
  2096.     params
  2097.       `(let ((segments nil)
  2098.          ,@(when newline-segment-p
  2099.          '((newline-segment nil)
  2100.            (extra-space 0)
  2101.            (line-len 72))))
  2102.      (block nil
  2103.        ,@(when newline-segment-p
  2104.            `((setf newline-segment
  2105.                (with-output-to-string (stream)
  2106.              ,@(expand-directive-list (pop segments))))
  2107.          ,(expand-bind-defaults
  2108.               ((extra 0)
  2109.                (line-len '(or (lisp::line-length stream) 72)))
  2110.               (format-directive-params first-semi)
  2111.             `(setf extra-space ,extra line-len ,line-len))))
  2112.        ,@(mapcar #'(lambda (segment)
  2113.              `(push (with-output-to-string (stream)
  2114.                   ,@(expand-directive-list segment))
  2115.                 segments))
  2116.              segments))
  2117.      (format-justification stream
  2118.                    ,@(if newline-segment-p
  2119.                      '(newline-segment extra-space line-len)
  2120.                      '(nil 0 0))
  2121.                    segments ,colonp ,atsignp
  2122.                    ,mincol ,colinc ,minpad ,padchar)))))
  2123.  
  2124. (defun interpret-format-justification
  2125.        (stream orig-args args segments colonp atsignp first-semi params)
  2126.   (interpret-bind-defaults
  2127.       ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
  2128.       params
  2129.     (let ((newline-string nil)
  2130.       (strings nil)
  2131.       (extra-space 0)
  2132.       (line-len 0))
  2133.       (setf args
  2134.         (catch 'up-and-out
  2135.           (when (and first-semi (format-directive-colonp first-semi))
  2136.         (interpret-bind-defaults
  2137.             ((extra 0)
  2138.              (len (or (lisp::line-length stream) 72)))
  2139.             (format-directive-params first-semi)
  2140.           (setf newline-string
  2141.             (with-output-to-string (stream)
  2142.               (setf args
  2143.                 (interpret-directive-list stream
  2144.                               (pop segments)
  2145.                               orig-args
  2146.                               args))))
  2147.           (setf extra-space extra)
  2148.           (setf line-len len)))
  2149.           (dolist (segment segments)
  2150.         (push (with-output-to-string (stream)
  2151.             (setf args
  2152.                   (interpret-directive-list stream segment
  2153.                             orig-args args)))
  2154.               strings))
  2155.           args))
  2156.       (format-justification stream newline-string extra-space line-len strings
  2157.                 colonp atsignp mincol colinc minpad padchar)))
  2158.   args)
  2159.  
  2160. (defun format-justification (stream newline-prefix extra-space line-len strings
  2161.                  pad-left pad-right mincol colinc minpad padchar)
  2162.   (setf strings (reverse strings))
  2163.   (when (and (not pad-left) (not pad-right) (null (cdr strings)))
  2164.     (setf pad-left t))
  2165.   (let* ((num-gaps (+ (1- (length strings))
  2166.               (if pad-left 1 0)
  2167.               (if pad-right 1 0)))
  2168.      (chars (+ (* num-gaps minpad)
  2169.            (loop
  2170.              for string in strings
  2171.              summing (length string))))
  2172.      (length (if (> chars mincol)
  2173.              (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
  2174.              mincol))
  2175.      (padding (- length chars)))
  2176.     (when (and newline-prefix
  2177.            (> (+ (or (lisp::charpos stream) 0)
  2178.              length extra-space)
  2179.           line-len))
  2180.       (write-string newline-prefix stream))
  2181.     (flet ((do-padding ()
  2182.          (let ((pad-len (truncate padding num-gaps)))
  2183.            (decf padding pad-len)
  2184.            (decf num-gaps)
  2185.            (dotimes (i pad-len) (write-char padchar stream)))))
  2186.       (when pad-left
  2187.     (do-padding))
  2188.       (when strings
  2189.     (write-string (car strings) stream)
  2190.     (dolist (string (cdr strings))
  2191.       (do-padding)
  2192.       (write-string string stream)))
  2193.       (when pad-right
  2194.     (do-padding)))))
  2195.  
  2196. (defun parse-format-logical-block
  2197.        (segments colonp first-semi close params string end)
  2198.   (when params
  2199.     (error 'format-error
  2200.        :complaint "No parameters can be supplied with ~~<...~~:>."
  2201.        :offset (caar params)))
  2202.   (multiple-value-bind
  2203.       (prefix insides suffix)
  2204.       (multiple-value-bind (prefix-default suffix-default)
  2205.                (if colonp (values "(" ")") (values nil nil))
  2206.     (flet ((extract-string (list prefix-p)
  2207.          (let ((directive (find-if #'format-directive-p list)))
  2208.            (if directive
  2209.                (error 'format-error
  2210.                   :complaint
  2211.                   "Cannot include format directives inside the ~
  2212.                    ~:[suffix~;prefix~] segment of ~~<...~~:>"
  2213.                   :arguments (list prefix-p)
  2214.                   :offset (1- (format-directive-end directive)))
  2215.                (apply #'concatenate 'string list)))))
  2216.     (case (length segments)
  2217.       (0 (values prefix-default nil suffix-default))
  2218.       (1 (values prefix-default (car segments) suffix-default))
  2219.       (2 (values (extract-string (car segments) t)
  2220.              (cadr segments) suffix-default))
  2221.       (3 (values (extract-string (car segments) t)
  2222.              (cadr segments)
  2223.              (extract-string (caddr segments) nil)))
  2224.       (t
  2225.        (error 'format-error
  2226.           :complaint "Too many segments for ~~<...~~:>.")))))
  2227.     (when (format-directive-atsignp close)
  2228.       (setf insides
  2229.         (add-fill-style-newlines insides
  2230.                      string
  2231.                      (if first-semi
  2232.                      (format-directive-end first-semi)
  2233.                      end))))
  2234.     (values prefix
  2235.         (and first-semi (format-directive-atsignp first-semi))
  2236.         insides
  2237.         suffix)))
  2238.  
  2239. (defun add-fill-style-newlines (list string offset)
  2240.   (if list
  2241.       (let ((directive (car list)))
  2242.     (if (simple-string-p directive)
  2243.         (nconc (add-fill-style-newlines-aux directive string offset)
  2244.            (add-fill-style-newlines (cdr list)
  2245.                         string
  2246.                         (+ offset (length directive))))
  2247.         (cons directive
  2248.           (add-fill-style-newlines (cdr list)
  2249.                        string
  2250.                        (format-directive-end directive)))))
  2251.       nil))
  2252.  
  2253. (defun add-fill-style-newlines-aux (literal string offset)
  2254.   (let ((end (length literal))
  2255.     (posn 0))
  2256.     (collect ((results))
  2257.       (loop
  2258.     (let ((blank (position #\space literal :start posn)))
  2259.       (when (null blank)
  2260.         (results (subseq literal posn))
  2261.         (return))
  2262.       (let ((non-blank (or (position #\space literal :start blank
  2263.                      :test #'char/=)
  2264.                    end)))
  2265.         (results (subseq literal posn non-blank))
  2266.         (results (make-format-directive
  2267.               :string string :character #\_
  2268.               :start (+ offset non-blank) :end (+ offset non-blank)
  2269.               :colonp t :atsignp nil :params nil))
  2270.         (setf posn non-blank))
  2271.       (when (= posn end)
  2272.         (return))))
  2273.       (results))))
  2274.  
  2275. (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
  2276.   `(let ((arg ,(if atsignp 'args (expand-next-arg))))
  2277.      ,@(when atsignp
  2278.      (setf *only-simple-args* nil)
  2279.      '((setf args nil)))
  2280.      (pprint-logical-block
  2281.      (stream arg
  2282.          ,(if per-line-p :per-line-prefix :prefix) ,prefix
  2283.          :suffix ,suffix)
  2284.        (let ((args arg)
  2285.          ,@(unless atsignp
  2286.          `((orig-args arg))))
  2287.      (declare (ignorable args ,@(unless atsignp '(orig-args))))
  2288.      (block nil
  2289.        ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
  2290.            (*only-simple-args* nil)
  2291.            (*orig-args-available* t))
  2292.            (expand-directive-list insides)))))))
  2293.  
  2294. (defun interpret-format-logical-block
  2295.        (stream orig-args args prefix per-line-p insides suffix atsignp)
  2296.   (let ((arg (if atsignp args (next-arg))))
  2297.     (if per-line-p
  2298.     (pprint-logical-block
  2299.         (stream arg :per-line-prefix prefix :suffix suffix)
  2300.       (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
  2301.         (catch 'up-and-out
  2302.           (interpret-directive-list stream insides
  2303.                     (if atsignp orig-args arg)
  2304.                     arg))))
  2305.     (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
  2306.       (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
  2307.         (catch 'up-and-out
  2308.           (interpret-directive-list stream insides
  2309.                     (if atsignp orig-args arg)
  2310.                     arg))))))
  2311.   (if atsignp nil args))
  2312.  
  2313. (def-complex-format-directive #\> ()
  2314.   (error 'format-error
  2315.      :complaint "No corresponding open bracket."))
  2316.  
  2317.  
  2318. ;;;; User-defined method.
  2319.  
  2320. (def-format-directive #\/ (string start end colonp atsignp params)
  2321.   (let ((symbol (extract-user-function-name string start end)))
  2322.     (collect ((param-names) (bindings))
  2323.       (dolist (param params)
  2324.     (let ((param-name (gensym)))
  2325.       (param-names param-name)
  2326.       (bindings `(,param-name
  2327.               ,(case param
  2328.              (:arg (expand-next-arg))
  2329.              (:remaining '(length args))
  2330.              (t param))))))
  2331.          `(let ,(bindings)
  2332.         (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
  2333.              ,@(param-names))))))
  2334.  
  2335. (def-format-interpreter #\/ (string start end colonp atsignp params)
  2336.   (let ((symbol (extract-user-function-name string start end)))
  2337.     (collect ((args))
  2338.       (dolist (param params)
  2339.     (case param
  2340.       (:arg (args (next-arg)))
  2341.       (:remaining (args (length args)))
  2342.       (t (args param))))
  2343.       (apply (fdefinition symbol) stream (next-arg)
  2344.          colonp atsignp (args)))))
  2345.  
  2346. (defun extract-user-function-name (string start end)
  2347.   (let ((slash (position #\/ string :start start :end (1- end)
  2348.              :from-end t)))
  2349.     (unless slash
  2350.       (error 'format-error
  2351.          :complaint "Malformed ~~/ directive."))
  2352.     (let* ((name (string-upcase (let ((foo string))
  2353.                   ;; Hack alert: This is to keep the compiler
  2354.                   ;; quit about deleting code inside the subseq
  2355.                   ;; expansion.
  2356.                   (subseq foo (1+ slash) (1- end)))))
  2357.        (first-colon (position #\: name))
  2358.        (last-colon (if first-colon (position #\: name :from-end t)))
  2359.        (package-name (if last-colon
  2360.                  (subseq name 0 first-colon)
  2361.                  "USER"))
  2362.        (package (find-package package-name)))
  2363.       (unless package
  2364.     (error 'format-error
  2365.            :complaint "No package named ``~A''."
  2366.            :arguments (list package-name)))
  2367.       (intern (if first-colon
  2368.           (subseq name (1+ first-colon))
  2369.           name)
  2370.           package))))
  2371.  
  2372.